The shape of tides

The goal of this project is to analyse tide times in Galway and try to extract some information on the periodicity of tide times. We’ll use methods from an area of maths called topology.

We first load the R-TDA package

#install.packages('TDA')
library(TDA)

We will now read tide times from 15/03-29/03.

tides <- read.csv(file="/Users/jamesmcgloin/Documents/CodingProjects/The-Shape-of-Tides/galwaytides.csv", nrows=3411, header=FALSE)
height <- tides[,8]

We now create an index to sample 200 values from our tide times

index = seq(1,200)

We create three vectors the first containing tide times at time \(t_0\) the second containing values at \(t_0 + 2hrs\) and the third at \(t+4hrs\) .

h <- c()  # heights
h2 <- c() # heights at t + 2h
h4 <- c() # heights at t + 4h
for (i in index) {
  h  <- append(h,  height[i])
  h2 <- append(h2, height[i+20])
  h4 <- append(h4, height[i+40])
}

We know create a data frame consisting of 3 columns corresponding to \(h\), \(h_2\) and \(h_4\) and create a \(3D\) plot of the data

#install.packages("plotly")
library(plotly)
Loading required package: ggplot2
Registered S3 method overwritten by 'data.table':
  method           from
  print.data.table     
Registered S3 method overwritten by 'htmlwidgets':
  method           from         
  print.htmlwidget tools:rstudio

Attaching package: ‘plotly’

The following object is masked from ‘package:ggplot2’:

    last_plot

The following object is masked from ‘package:stats’:

    filter

The following object is masked from ‘package:graphics’:

    layout
data = data.frame(h,h2,h4)
fig <-plot_ly(data = data, x=~h, y=~h2, z=~h4, type="scatter3d", mode="markers")%>%
        layout(title = 'Tide Heights', plot_bgcolor = "#e5ecf6")
fig

We can see clearly from this plot that there is some periodic motion going on in our data. We’ll now look at a way of extracting this info using topological data analysis.

We create our Vietoris Rips complex using the ripsDiag() function. I’l set max dimension as 1 as I won’t be considering persistence in the second homology group or above. In fact this would be ineffecient to calculate and, at least in \(H_2\), we don’t detect any interesting features (I didn’t bother computing for higher homology groups but I suspect a similar result ).

I’ll set max scale to 5 as this turns out to be an appropriate scale for our data and I’ll use the standard Eulidean distance as our metric.

maxdimension <- 1
maxscale <- 5
Diag <- ripsDiag(X = data.frame(h,h2,h4),
                 maxdimension,
                 maxscale,
                 dist = "euclidean",
                 library = "GUDHI",
                 printProgress = FALSE)

Now we plot a persistence diagram of our data

#print(Diag[["diagram"]])
plot(Diag[["diagram"]], barcode=FALSE,  main = "Persistence Diagram")
legend(3.5, 5, legend=c("Holes", "Components"),
       col=c("red", "black"), cex=0.8, pch = c(17,19))

The red triangles in our diagrams correspond to birth/death times of “holes” and the black dots correspond to birth/death times of connected components

And finally we output a barcode of persisting features in \(H_0\) and \(H_1\).

plot(Diag[["diagram"]], barcode=TRUE,  main = "Barcode")
legend("topright", legend=c("Holes", "Components"),
       col=c("red", "black"), cex=0.8, lty= 1:1)

Conclusion

We see from both the persistence diagram and the bar code that there is persistence in the second homology group, i.e. there is a 1-dimensional hole in our data.

This is exactly what we should expect with the motion of the tide! Really the hole that we are picking up on is that of the moon orbiting the earth which in my opinion is pretty neat.

LS0tCnRpdGxlOiAiVGhlIFNoYXBlIG9mIFRpZGVzIgpvdXRwdXQ6IGh0bWxfbm90ZWJvb2sKLS0tCgojIFRoZSBzaGFwZSBvZiB0aWRlcwoKVGhlIGdvYWwgb2YgdGhpcyBwcm9qZWN0IGlzIHRvIGFuYWx5c2UgdGlkZSB0aW1lcyBpbiBHYWx3YXkgYW5kIHRyeSB0byBleHRyYWN0IHNvbWUgaW5mb3JtYXRpb24gb24gdGhlIHBlcmlvZGljaXR5IG9mIHRpZGUgdGltZXMuIFdlJ2xsIHVzZSBtZXRob2RzIGZyb20gYW4gYXJlYSBvZiBtYXRocyBjYWxsZWQgdG9wb2xvZ3kuCgpXZSBmaXJzdCBsb2FkIHRoZSBSLVREQSBwYWNrYWdlCgpgYGB7cn0KI2luc3RhbGwucGFja2FnZXMoJ1REQScpCmxpYnJhcnkoVERBKQpgYGAKCldlIHdpbGwgbm93IHJlYWQgdGlkZSB0aW1lcyBmcm9tIDE1LzAzLTI5LzAzLgoKYGBge3J9CnRpZGVzIDwtIHJlYWQuY3N2KGZpbGU9Ii9Vc2Vycy9qYW1lc21jZ2xvaW4vRG9jdW1lbnRzL0NvZGluZ1Byb2plY3RzL1RoZS1TaGFwZS1vZi1UaWRlcy9nYWx3YXl0aWRlcy5jc3YiLCBucm93cz0zNDExLCBoZWFkZXI9RkFMU0UpCmhlaWdodCA8LSB0aWRlc1ssOF0KYGBgCgpXZSBub3cgY3JlYXRlIGFuIGluZGV4IHRvIHNhbXBsZSAyMDAgdmFsdWVzIGZyb20gb3VyIHRpZGUgdGltZXMKCmBgYHtyfQppbmRleCA9IHNlcSgxLDIwMCkKYGBgCgpXZSBjcmVhdGUgdGhyZWUgdmVjdG9ycyB0aGUgZmlyc3QgY29udGFpbmluZyB0aWRlIHRpbWVzIGF0IHRpbWUgJHRfMCQgdGhlIHNlY29uZCBjb250YWluaW5nIHZhbHVlcyBhdCAkdF8wICsgMmhycyQgYW5kIHRoZSB0aGlyZCBhdCAkdCs0aHJzJCAuCgpgYGB7cn0KaCA8LSBjKCkgICMgaGVpZ2h0cwpoMiA8LSBjKCkgIyBoZWlnaHRzIGF0IHQgKyAyaApoNCA8LSBjKCkgIyBoZWlnaHRzIGF0IHQgKyA0aApmb3IgKGkgaW4gaW5kZXgpIHsKICBoICA8LSBhcHBlbmQoaCwgIGhlaWdodFtpXSkKICBoMiA8LSBhcHBlbmQoaDIsIGhlaWdodFtpKzIwXSkKICBoNCA8LSBhcHBlbmQoaDQsIGhlaWdodFtpKzQwXSkKfQpgYGAKCldlIGtub3cgY3JlYXRlIGEgZGF0YSBmcmFtZSBjb25zaXN0aW5nIG9mIDMgY29sdW1ucyBjb3JyZXNwb25kaW5nIHRvICRoJCwgJGhfMiQgYW5kICRoXzQkIGFuZCBjcmVhdGUgYSAkM0QkIHBsb3Qgb2YgdGhlIGRhdGEKCmBgYHtyfQojaW5zdGFsbC5wYWNrYWdlcygicGxvdGx5IikKbGlicmFyeShwbG90bHkpCmBgYAoKYGBge3J9CmRhdGEgPSBkYXRhLmZyYW1lKGgsaDIsaDQpCmZpZyA8LXBsb3RfbHkoZGF0YSA9IGRhdGEsIHg9fmgsIHk9fmgyLCB6PX5oNCwgdHlwZT0ic2NhdHRlcjNkIiwgbW9kZT0ibWFya2VycyIpJT4lCiAgICAgICAgbGF5b3V0KHRpdGxlID0gJ1RpZGUgSGVpZ2h0cycsIHBsb3RfYmdjb2xvciA9ICIjZTVlY2Y2IikKZmlnCmBgYAoKV2UgY2FuIHNlZSBjbGVhcmx5IGZyb20gdGhpcyBwbG90IHRoYXQgdGhlcmUgaXMgc29tZSBwZXJpb2RpYyBtb3Rpb24gZ29pbmcgb24gaW4gb3VyIGRhdGEuIFdlJ2xsIG5vdyBsb29rIGF0IGEgd2F5IG9mIGV4dHJhY3RpbmcgdGhpcyBpbmZvIHVzaW5nIHRvcG9sb2dpY2FsIGRhdGEgYW5hbHlzaXMuCgpXZSBjcmVhdGUgb3VyIFZpZXRvcmlzIFJpcHMgY29tcGxleCB1c2luZyB0aGUgcmlwc0RpYWcoKSBmdW5jdGlvbi4gSSdsIHNldCBtYXggZGltZW5zaW9uIGFzIDEgYXMgSSB3b24ndCBiZSBjb25zaWRlcmluZyBwZXJzaXN0ZW5jZSBpbiB0aGUgc2Vjb25kIGhvbW9sb2d5IGdyb3VwIG9yIGFib3ZlLiBJbiBmYWN0IHRoaXMgd291bGQgYmUgaW5lZmZlY2llbnQgdG8gY2FsY3VsYXRlIGFuZCwgYXQgbGVhc3QgaW4gJEhfMiQsIHdlIGRvbid0IGRldGVjdCBhbnkgaW50ZXJlc3RpbmcgZmVhdHVyZXMgKEkgZGlkbid0IGJvdGhlciBjb21wdXRpbmcgZm9yIGhpZ2hlciBob21vbG9neSBncm91cHMgYnV0IEkgc3VzcGVjdCBhIHNpbWlsYXIgcmVzdWx0ICkuCgpJJ2xsIHNldCBtYXggc2NhbGUgdG8gNSBhcyB0aGlzIHR1cm5zIG91dCB0byBiZSBhbiBhcHByb3ByaWF0ZSBzY2FsZSBmb3Igb3VyIGRhdGEgYW5kIEknbGwgdXNlIHRoZSBzdGFuZGFyZCBFdWxpZGVhbiBkaXN0YW5jZSBhcyBvdXIgbWV0cmljLgoKYGBge3J9Cm1heGRpbWVuc2lvbiA8LSAxCm1heHNjYWxlIDwtIDUKRGlhZyA8LSByaXBzRGlhZyhYID0gZGF0YS5mcmFtZShoLGgyLGg0KSwKICAgICAgICAgICAgICAgICBtYXhkaW1lbnNpb24sCiAgICAgICAgICAgICAgICAgbWF4c2NhbGUsCiAgICAgICAgICAgICAgICAgZGlzdCA9ICJldWNsaWRlYW4iLAogICAgICAgICAgICAgICAgIGxpYnJhcnkgPSAiR1VESEkiLAogICAgICAgICAgICAgICAgIHByaW50UHJvZ3Jlc3MgPSBGQUxTRSkKYGBgCgpOb3cgd2UgcGxvdCBhIHBlcnNpc3RlbmNlIGRpYWdyYW0gb2Ygb3VyIGRhdGEKCmBgYHtyfQojcHJpbnQoRGlhZ1tbImRpYWdyYW0iXV0pCnBsb3QoRGlhZ1tbImRpYWdyYW0iXV0sIGJhcmNvZGU9RkFMU0UsICBtYWluID0gIlBlcnNpc3RlbmNlIERpYWdyYW0iKQpsZWdlbmQoMy41LCA1LCBsZWdlbmQ9YygiSG9sZXMiLCAiQ29tcG9uZW50cyIpLAogICAgICAgY29sPWMoInJlZCIsICJibGFjayIpLCBjZXg9MC44LCBwY2ggPSBjKDE3LDE5KSkKYGBgCgpUaGUgcmVkIHRyaWFuZ2xlcyBpbiBvdXIgZGlhZ3JhbXMgY29ycmVzcG9uZCB0byBiaXJ0aC9kZWF0aCB0aW1lcyBvZiAiaG9sZXMiIGFuZCB0aGUgYmxhY2sgZG90cyBjb3JyZXNwb25kIHRvIGJpcnRoL2RlYXRoIHRpbWVzIG9mIGNvbm5lY3RlZCBjb21wb25lbnRzCgpBbmQgZmluYWxseSB3ZSBvdXRwdXQgYSBiYXJjb2RlIG9mIHBlcnNpc3RpbmcgZmVhdHVyZXMgaW4gJEhfMCQgYW5kICRIXzEkLgoKYGBge3J9CnBsb3QoRGlhZ1tbImRpYWdyYW0iXV0sIGJhcmNvZGU9VFJVRSwgIG1haW4gPSAiQmFyY29kZSIpCmxlZ2VuZCgidG9wcmlnaHQiLCBsZWdlbmQ9YygiSG9sZXMiLCAiQ29tcG9uZW50cyIpLAogICAgICAgY29sPWMoInJlZCIsICJibGFjayIpLCBjZXg9MC44LCBsdHk9IDE6MSkKYGBgCgojIyBDb25jbHVzaW9uCgpXZSBzZWUgZnJvbSBib3RoIHRoZSBwZXJzaXN0ZW5jZSBkaWFncmFtIGFuZCB0aGUgYmFyIGNvZGUgdGhhdCB0aGVyZSBpcyBwZXJzaXN0ZW5jZSBpbiB0aGUgc2Vjb25kIGhvbW9sb2d5IGdyb3VwLCBpLmUuIHRoZXJlIGlzIGEgMS1kaW1lbnNpb25hbCBob2xlIGluIG91ciBkYXRhLgoKVGhpcyBpcyBleGFjdGx5IHdoYXQgd2Ugc2hvdWxkIGV4cGVjdCB3aXRoIHRoZSBtb3Rpb24gb2YgdGhlIHRpZGUhIFJlYWxseSB0aGUgaG9sZSB0aGF0IHdlIGFyZSBwaWNraW5nIHVwIG9uIGlzIHRoYXQgb2YgdGhlIG1vb24gb3JiaXRpbmcgdGhlIGVhcnRoIHdoaWNoIGluIG15IG9waW5pb24gaXMgcHJldHR5IG5lYXQuCgo=